
;;; file: pages.lisp
;;;
;;; Copyright (c) 2010 Steffen Schulz (pepe@virtuallysecure.org)
;;; Copyright (c) 2007-2009 Cyrus Harmon (ch-lisp@bobobeach.com)
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;

(in-package :parseltongue)

(defun entry-link (blog entry)
  (concatenate-url
    (blog-display-entry-url blog)
    "?id="
    (url-encode (prin1-to-string (blog-entry-number entry)))))

(defmacro box ((&key class id) head &rest body)
  `(with-html
     (:div :id ,id :class ,(concatenate 'string "blog-box " class)
           ,(when head
              `(:div :class "blog-box-head"
                     ,head))
           (:div :class "blog-box-body"
                 ,@body))))

(defun recent-entries-box (blog)
  (with-html
    (box (:class "blog-nav-box" :id "blog-nav-box-recent-entries")
         (:h2 "Recent entries")
         (:ul
           (loop for i from 1 to 10
                 for entry in (blog-entries blog)
                 do (htm
                      (:li
                        (:a :href (entry-link blog entry)
                            (str (blog-entry-title entry))))))))))

;; TODO: This is not yet a cloud...but do we want one?
(defun tag-cloud-box (blog)
  (with-html
    (box (:class "blog-nav-box" :id "blog-nav-box-tag-cloud")
         (:h2 "Tags")
         (:ul
           (loop for tag being the hash-keys of (blog-tag-stats blog)
                 do (htm
                      (:li (:a :href (blog-archive-url blog :tag tag) (str tag))
                           " "
                           (:a :href (blog-archive-url blog :rss t :tag tag)
                               (if (> (length (blog-feed-img-uri blog)) 0)
                                 (format t "<img src=\"~A\">" (blog-feed-img-uri blog))
                                 (str "(rss)")))
                           " (" (str (gethash tag (blog-tag-stats blog))) ")" )))))))

(defun buttons (blog)
  (with-html
    (box (:class "blog-nav-box nav-button" :id "blog-nav-box-buttons")
         nil
         (:ul
           (loop for button in (blog-buttons blog)
                 do
                 (destructuring-bind (&key href-url id img-url alt) button
                   (htm
                     (:li
                       (:a :href href-url :class "blog-button"
                           (:img :id id
                                 :src img-url
                                 :alt (escape-string alt)))))))))))

(defun main-nav-box (blog)
  (box (:class "blog-nav-box" :id "blog-nav-box-main")
       (:h2 (str (blog-short-name blog)))
       (:ul
         (:li (:a :href (blog-root-uri blog) "Blog"))
         (:li (:a :href (blog-archive-url blog) "Archive"))
         (:li
           (:a :href (blog-archive-url blog :rss t) "Feed")
           " "
           (:a :href (blog-archive-url blog :rss t :mode "full") "(full)"))
         (if (http-authenticate blog nil)
           (htm
             (:li (:a :href (blog-new-entry-url blog) "New entry"))
             (:li (:a :href (blog-logout-url blog) "Logout")))
           (htm :li (:a :href (blog-login-url blog) "Login")))
         (:li (:a :href (blog-email-uri blog) "Contact")))))

;; TODO: move list to configuration struct
(defun links-box (blog)
  (box (:class "blog-nav-box" :id "blog-nav-box-links")
       (:h2 "Links")
       (:ul
         (dolist (link '(
                         ("http://www.nachdenkseiten.de" . "NachDenkSeiten")
                         ("http://blog.fefe.de" . "Die brandheissen News")
                         ("http://dilbert.com/fast/" . "Dilbert of the Day")
                         ))
           (htm (:li (:a :href (car link) (str (cdr link)))))))))

;; TODO: move list to configuration struct
(defun site-nav-box (blog)
  (box (:class "blog-nav-box" :id "blog-nav-box-links")
       (:h2 "Links")
       (:ul
         (dolist (link '("http://www.heise.de" "http://www.slashdot.org"))
           (htm (:li (:a :href link (str link))))))))


;; TODO: Add box of static pages("projects")
(defun left-column (blog)
  (with-html-output (*standard-output*)
                    (:div :id "blog-left-col" :class "blog-nav"
                          (main-nav-box blog)
                          ; (site-nav-box blog)
                          (recent-entries-box blog)
                          (links-box blog)
                          (buttons blog))))

(defun right-column (blog)
  (with-html-output (*standard-output*)
                    (:div :id "blog-right-col" :class "blog-nav"
                          (tag-cloud-box blog)
                          )))

(defun banner (blog)
  (with-html
    (:div :class "blog-banner"
          (let ((url (blog-logo-img-uri blog)))
            (when (> (length url) 0)
              (htm (:div :id "blog-bannerleft"
                         (:img :class "blog-titlelogo" :src url :alt ""))
                   "&nbsp;")))
          (:div :id "blog-bannertext"
                (:h1 (str (blog-title blog)))
                (:h2 (str (blog-subtitle blog))))
          (:div :class "blog-pad" "&nbsp;"))))

(defun footer (blog)
  (with-html
    (:div :class "blog-footer" (blog-footer blog))))

(defmacro with-blog-page (blog title &body body)
  `(with-html-page
     ((:html :xmlns "http://www.w3.org/1999/xhtml") 
      (:head
        (:link :rel "alternate" :type "application/rss+xml" :title "shortened feed"
               :href (blog-archive-url ,blog :rss t))
        (:link :rel "alternate" :type "application/rss+xml" :title "full text feed"
               :href (blog-archive-url ,blog :rss t :mode "full"))
        (:title (str ,title))
        (loop for style in (blog-page-css-uri ,blog)
              do
              (htm
                (:link :rel "stylesheet"
                       :title (car style) :type "text/css" :href (cdr style)))))
      (:body
        (banner ,blog)
        (:div :id "blog-main"
              (left-column ,blog)
              (:div :id "blog-content"
                    (progn
                      ,@body))
              (right-column ,blog))
        (footer ,blog)))))
